home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / BBS-Archive / Dev / GNU-TILE-FORTH.lha / tst / relations.tst < prev    next >
Text File  |  1992-05-19  |  3KB  |  200 lines
  1. .( Loading Relations test...) cr
  2.  
  3. #include relations.f83
  4. #include blocks.f83
  5.  
  6. string blocks relations
  7.  
  8. .( 1: Some simple items and relations between them) cr
  9.  
  10. item a
  11. item b
  12. item c
  13. item d
  14. .items cr
  15.  
  16. 10 a a put-relation
  17. 11 b a put-relation
  18. 12 c a put-relation
  19. 13 d a put-relation
  20.  
  21. a .relations cr
  22. b .relations cr
  23. c .relations cr
  24. d .relations cr
  25. a .values cr
  26.  
  27. a a remove-relation
  28. a .values cr
  29.  
  30. d a remove-relation
  31. a .values cr
  32.  
  33. item Joe
  34. item address
  35. item profession
  36.  
  37. " Forth road 4, Forthiana" address Joe put-relation
  38. " Forth Hacker" profession Joe put-relation
  39. Joe .values cr
  40. cr
  41.  
  42. .( 2: Reflexive and symmetric relations) cr
  43.  
  44. : reflexive ( relation item -- )
  45.   tuck put-relation
  46. ;
  47.  
  48. : symmetric ( item1 relation item2 -- )
  49.   >r 2dup r@ put-relation
  50.   r> swap rot put-relation
  51. ;
  52.  
  53. .( 3: Directions and opposite directions) cr
  54.  
  55. item north
  56. item south
  57. item east
  58. item west
  59. item opposite
  60. .items cr
  61.  
  62. north opposite south symmetric
  63. east  opposite west  symmetric
  64.  
  65. opposite block[ ( value item -- ) 
  66.   .item space opposite .item space .item cr
  67. ]; map-relation
  68. cr
  69.  
  70. .( 4: A small map with locations and paths) cr
  71.  
  72. : location ( -- )
  73.   item
  74. ;
  75.  
  76. : path ( from direction to -- )
  77.   >r 2dup r@ put-relation
  78.   opposite swap get-relation
  79.   r> swap rot put-relation
  80. ;
  81.  
  82. location HardwareShop
  83. location Macdonalds
  84. location Drugstore
  85. location Hotel
  86. .items cr
  87.  
  88. Hotel west HardwareShop path
  89. Macdonalds south Hotel path
  90. Drugstore west Macdonalds path
  91. Hotel east Hotel path
  92.  
  93. Hotel .relations cr
  94. Macdonalds .relations cr
  95. HardwareShop .relations cr
  96. Drugstore .relations cr
  97. cr
  98.  
  99. .( 5: Sets, Bags and Dictionaries using relations) cr
  100.  
  101. : occurencesOf ( element set -- value)
  102.   ?get-relation not if 2drop 0 then
  103. ;
  104.  
  105. : ?includes ( element set -- flag)
  106.   occurencesOf boolean
  107. ;  
  108.  
  109. : add ( element set -- )
  110.   1 -rot put-relation
  111. ;
  112.  
  113. : remove ( element set -- )
  114.   remove-relation
  115. ;
  116.  
  117. : addWithOccurrences ( value element bag -- )
  118.   2dup 2>r occurencesOf + 2r> put-relation
  119. ;
  120.  
  121. item x
  122. item aSet
  123. item aBag
  124. item aDictionary
  125. .items cr
  126.  
  127. x aSet ?includes .
  128. x aSet add
  129. x aSet ?includes .
  130. x aSet remove
  131. 10 x aBag addWithOccurrences
  132. x aBag occurencesOf .
  133. 10 x aBag addWithOccurrences
  134. x aBag occurencesOf .
  135. x aBag remove
  136. x aBag occurencesOf .
  137. x aDictionary ?includes .
  138. 100 x aDictionary put-relation
  139. x aDictionary get-relation . cr
  140. aSet .relations cr
  141. aBag .relations cr
  142. aDictionary .relations cr
  143. cr
  144.  
  145. .( 6: Item relation database dump example) cr
  146.  
  147. item dump
  148.  
  149. item is-an-item
  150.  
  151. is-an-item dump dump put-relation
  152. is-an-item dump north put-relation
  153. is-an-item dump west put-relation
  154. is-an-item dump south put-relation
  155. is-an-item dump east put-relation
  156. is-an-item dump opposite put-relation
  157.  
  158. item is-a-string
  159.  
  160. is-a-string dump address put-relation
  161. is-a-string dump profession put-relation
  162.  
  163. : dump-items ( -- )
  164.   block[ ( item -- )
  165.     ." item " .item cr
  166.   ];
  167.   map-items
  168. ;  
  169.  
  170. : dump-item-values ( -- )
  171.   block[ ( item -- )
  172.     dup
  173.     block[ ( item value attribute -- item)
  174.       tuck dump swap ?get-relation
  175.       if
  176.     case
  177.       is-an-item of .item space endof
  178.       is-a-string of ascii " emit space $print ascii " emit space endof
  179.       swap .
  180.     endcase
  181.       else
  182.     2drop .
  183.       then
  184.       .item space dup .item space ." put-relation" cr
  185.     ];
  186.     map-item 
  187.     drop
  188.   ];
  189.   map-items
  190. ;
  191.  
  192. \ Dump the current set of items and their values in a loadable form
  193.  
  194. dump-items cr
  195. dump-item-values cr
  196. cr
  197.  
  198. forth only
  199.  
  200.